;;;
;;; fetch.scm - fetch http filesystem
;;;
;;;   Copyright (c) 2008 Teruaki Gemma <teruakigemma@gmail.com>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
;;;  $Id$
;;;

(use srfi-1)
(use file.util)
(use gauche.uvector)
(use rfc.http)
(use rfc.uri)
(use sxml.ssax)
(use sxml.sxpath)
(use sxml.tools)
(use sxml.serializer)
(use sxml.tree-trans)
(use fuse)

(load "/home/teruaki/garakuta-okiba/wnix/adhoc.scm")

(define (fetch uri)
  (define (split-uri uri)
    (receive (scheme userinfo hostname port path query fragment) (uri-parse uri)
      (and-let* ((server (#/^\/\/(.+)\/$/ (uri-compose :userinfo userinfo :host hostname :port port)))
		 (request-uri (#/^\/\/(.+)$/   (uri-compose :path path :query query :fragment fragment))))
	(values (server 1) (request-uri 1)))))
  (receive (server request-uri) (split-uri uri)
    (receive (status header body) (http-get server request-uri)
      (cond
       ((string=? status "200") body)
       (else #f)))))

(define (fetch-and-save srcpath destpath)
  (define (remove-namespace-prefix sxml)
    (pre-post-order sxml
		    `((*text* . ,(lambda (trigger x) x))
		      (*default* . ,(lambda x
				      (let1 str (symbol->string (sxml:name x))
					(rxmatch-cond
					  ((rxmatch #/http\:\/\/\S+\:(.*)/ str)
					   (#f name)
					   (sxml:change-name x (string->symbol name)))
					  (else x))))))))

  (and-let* ((sxml (call-with-input-file srcpath (cut ssax:xml->sxml <> '())))
	     (node ((if-car-sxpath "/fetch") sxml))
	     (url ((if-car-sxpath "/@href/text()") node))
	     (body (fetch url))
	     (body-sxml (call-with-input-string body (cut ssax:xml->sxml <> '())))
	     (body-sxml-content ((if-sxpath "/*") body-sxml)))
    (sxml:change-content! node body-sxml-content)
    (call-with-output-file destpath (cut srl:sxml->xml (remove-namespace-prefix sxml) <>))))

(define (my-getattr path)
  (cond
   ((adhoc-shell-cmd path)
    => (lambda (shellcmd)
	 (xml-writer "./com/1"
		     (call-with-input-process shellcmd (cut ssax:xml->sxml <> '()))
		     #f)
	 (sys-stat "./com/1")))
   (else (sys-stat (string-append "./root" path)))))

(define (my-readdir path file-info)
  (cond
   ((string=? "/" path)
    (for-each (lambda (x)
		(unless (file-is-regular? (string-append "./down/" x))
		  (fetch-and-save (string-append "./data/" x)
				  (string-append "./root/" x))))
	      (values-ref (directory-list2 "./data") 1))
    (sys-readdir "./root"))
   (else (- ENOENT))))

(define (my-open path file-info)
  (cond
   ((adhoc-shell-cmd path)
    0)
   ((file-exists? (string-append "./root" path))
    0)
   (else (- ENOENT))))

(define (my-read path out size offset file-info)
  (define (copy-port-block src dest size offset)
    (define vec (make-u8vector size))
    (port-seek src offset)
    (let1 r (read-block! vec src)
      (and (not (eof-object? r))
	   (write-block vec dest)
	   r)))

  (cond
   ((adhoc-shell-cmd path)
    (call-with-input-file "./com/1" (cut copy-port-block <> out size offset)))
   (else
    (call-with-input-file (string-append "./root" path) (cut copy-port-block <> out size offset)))))

(define (main args)
  (start-fuse (car (last-pair args))
	      :args args
	      :multithreaded #f
	      :getattr  my-getattr
	      ;;:access   sys-access
	      ;;:readlink sys-readlink
	      ;;:mkdir    sys-mkdir
	      ;;:symlink  sys-symlink
	      ;;:unlink   sys-unlink
	      ;;:rmdir    sys-rmdir
	      ;;:rename   sys-rename
	      ;;:link     sys-link
	      ;;:chmod    sys-chmod
	      ;;:chown    sys-chown
	      ;;:truncate sys-truncate
	      ;;:utimens  sys-utime
	      ;;:statfs   sys-statvfs
	      :readdir  my-readdir
	      ;;:mknod    my-mknod
	      :open     my-open
	      :read     my-read
	      ;;:write    my-write
	      ))
